home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / win / tclWinInit.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  10.3 KB  |  395 lines  |  [TEXT/CWIE]
  1. /* 
  2.  * tclWinInit.c --
  3.  *
  4.  *    Contains the Windows-specific interpreter initialization functions.
  5.  *
  6.  * Copyright (c) 1994-1996 Sun Microsystems, Inc.
  7.  *
  8.  * See the file "license.terms" for information on usage and redistribution
  9.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  10.  *
  11.  * SCCS: @(#) tclWinInit.c 1.32 97/06/24 17:28:26
  12.  */
  13.  
  14. #include "tclInt.h"
  15. #include "tclPort.h"
  16. #include <winreg.h>
  17. #include <winnt.h>
  18. #include <winbase.h>
  19.  
  20. /*
  21.  * The following declaration is a workaround for some Microsoft brain damage.
  22.  * The SYSTEM_INFO structure is different in various releases, even though the
  23.  * layout is the same.  So we overlay our own structure on top of it so we
  24.  * can access the interesting slots in a uniform way.
  25.  */
  26.  
  27. typedef struct {
  28.     WORD wProcessorArchitecture;
  29.     WORD wReserved;
  30. } OemId;
  31.  
  32. /*
  33.  * The following macros are missing from some versions of winnt.h.
  34.  */
  35.  
  36. #ifndef PROCESSOR_ARCHITECTURE_INTEL
  37. #define PROCESSOR_ARCHITECTURE_INTEL 0
  38. #endif
  39. #ifndef PROCESSOR_ARCHITECTURE_MIPS
  40. #define PROCESSOR_ARCHITECTURE_MIPS  1
  41. #endif
  42. #ifndef PROCESSOR_ARCHITECTURE_ALPHA
  43. #define PROCESSOR_ARCHITECTURE_ALPHA 2
  44. #endif
  45. #ifndef PROCESSOR_ARCHITECTURE_PPC
  46. #define PROCESSOR_ARCHITECTURE_PPC   3
  47. #endif
  48. #ifndef PROCESSOR_ARCHITECTURE_UNKNOWN
  49. #define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF
  50. #endif
  51.  
  52. /*
  53.  * The following arrays contain the human readable strings for the Windows
  54.  * platform and processor values.
  55.  */
  56.  
  57.  
  58. #define NUMPLATFORMS 3
  59. static char* platforms[NUMPLATFORMS] = {
  60.     "Win32s", "Windows 95", "Windows NT"
  61. };
  62.  
  63. #define NUMPROCESSORS 4
  64. static char* processors[NUMPROCESSORS] = {
  65.     "intel", "mips", "alpha", "ppc"
  66. };
  67.  
  68. /*
  69.  * The following string is the startup script executed in new
  70.  * interpreters.  It looks on disk in several different directories
  71.  * for a script "init.tcl" that is compatible with this version
  72.  * of Tcl.  The init.tcl script does all of the real work of
  73.  * initialization.
  74.  */
  75.  
  76. static char *initScript =
  77. "proc init {} {\n\
  78.     global tcl_library tcl_platform tcl_version tcl_patchLevel env errorInfo\n\
  79.     global tcl_pkgPath\n\
  80.     rename init {}\n\
  81.     set errors {}\n\
  82.     proc tcl_envTraceProc {lo n1 n2 op} {\n\
  83.     global env\n\
  84.     set x $env($n2)\n\
  85.     set env($lo) $x\n\
  86.     set env([string toupper $lo]) $x\n\
  87.     }\n\
  88.     foreach p [array names env] {\n\
  89.     set u [string toupper $p]\n\
  90.     if {$u != $p} {\n\
  91.         switch -- $u {\n\
  92.         COMSPEC -\n\
  93.         PATH {\n\
  94.             if {![info exists env($u)]} {\n\
  95.             set env($u) $env($p)\n\
  96.             }\n\
  97.             trace variable env($p) w [list tcl_envTraceProc $p]\n\
  98.             trace variable env($u) w [list tcl_envTraceProc $p]\n\
  99.         }\n\
  100.         }\n\
  101.     }\n\
  102.     }\n\
  103.     if {![info exists env(COMSPEC)]} {\n\
  104.     if {$tcl_platform(os) == {Windows NT}} {\n\
  105.         set env(COMSPEC) cmd.exe\n\
  106.     } else {\n\
  107.         set env(COMSPEC) command.com\n\
  108.     }\n\
  109.     }    \n\
  110.     set dirs {}\n\
  111.     if {[info exists env(TCL_LIBRARY)]} {\n\
  112.     lappend dirs $env(TCL_LIBRARY)\n\
  113.     }\n\
  114.     lappend dirs $tcl_library\n\
  115.     lappend dirs [file join [file dirname [file dirname [info nameofexecutable]]] lib/tcl$tcl_version]\n\
  116.     if [string match {*[ab]*} $tcl_patchLevel] {\n\
  117.     set lib tcl$tcl_patchLevel\n\
  118.     } else {\n\
  119.     set lib tcl$tcl_version\n\
  120.     }\n\
  121.     lappend dirs [file join [file dirname [file dirname [pwd]]] $lib/library]\n\
  122.     lappend dirs [file join [file dirname [pwd]] library]\n\
  123.     foreach i $dirs {\n\
  124.     set tcl_library $i\n\
  125.     set tclfile [file join $i init.tcl]\n\
  126.     if {[file exists $tclfile]} {\n\
  127.             lappend tcl_pkgPath [file dirname $i]\n\
  128.         if ![catch {uplevel #0 [list source $tclfile]} msg] {\n\
  129.             return\n\
  130.         } else {\n\
  131.         append errors \"$tclfile: $msg\n$errorInfo\n\"\n\
  132.         }\n\
  133.     }\n\
  134.     }\n\
  135.     set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\
  136.     append msg \"    $dirs\n\n\"\n\
  137.     append msg \"$errors\n\n\"\n\
  138.     append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\
  139.     error $msg\n\
  140. }\n\
  141. init\n";
  142.  
  143. /*
  144.  *----------------------------------------------------------------------
  145.  *
  146.  * TclPlatformInit --
  147.  *
  148.  *    Performs Windows-specific interpreter initialization related to the
  149.  *    tcl_library variable.  Also sets up the HOME environment variable
  150.  *    if it is not already set.
  151.  *
  152.  * Results:
  153.  *    None.
  154.  *
  155.  * Side effects:
  156.  *    Sets "tcl_library" and "env(HOME)" Tcl variables
  157.  *
  158.  *----------------------------------------------------------------------
  159.  */
  160.  
  161. void
  162. TclPlatformInit(interp)
  163.     Tcl_Interp *interp;
  164. {
  165.     char *ptr;
  166.     char buffer[13];
  167.     Tcl_DString ds;
  168.     OSVERSIONINFO osInfo;
  169.     SYSTEM_INFO sysInfo;
  170.     int isWin32s;        /* True if we are running under Win32s. */
  171.     OemId *oemId;
  172.     HKEY key;
  173.     DWORD size;
  174.  
  175.     tclPlatform = TCL_PLATFORM_WINDOWS;
  176.  
  177.     Tcl_DStringInit(&ds);
  178.  
  179.     /*
  180.      * Find out what kind of system we are running on.
  181.      */
  182.  
  183.     osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
  184.     GetVersionEx(&osInfo);
  185.  
  186.     isWin32s = (osInfo.dwPlatformId == VER_PLATFORM_WIN32s);
  187.  
  188.     /*
  189.      * Since Win32s doesn't support GetSystemInfo, we use a default value.
  190.      */
  191.  
  192.     oemId = (OemId *) &sysInfo;
  193.     if (!isWin32s) {
  194.     GetSystemInfo(&sysInfo);
  195.     } else {
  196.     oemId->wProcessorArchitecture = PROCESSOR_ARCHITECTURE_INTEL;
  197.     }
  198.  
  199.     /*
  200.      * Initialize the tcl_library variable from the registry.
  201.      */
  202.  
  203.     if (!isWin32s) {
  204.     if ((RegOpenKeyEx(HKEY_LOCAL_MACHINE,
  205.         "Software\\Sun\\Tcl\\" TCL_VERSION, 0, KEY_READ, &key)
  206.         == ERROR_SUCCESS)
  207.         && (RegQueryValueEx(key, "Root", NULL, NULL, NULL, &size)
  208.             == ERROR_SUCCESS)) {
  209.         Tcl_DStringSetLength(&ds, size);
  210.         RegQueryValueEx(key, "Root", NULL, NULL,
  211.             (LPBYTE)Tcl_DStringValue(&ds), &size);
  212.     }
  213.     } else {
  214.     if ((RegOpenKeyEx(HKEY_CLASSES_ROOT,
  215.         "Software\\Sun\\Tcl\\" TCL_VERSION, 0, KEY_READ, &key)
  216.         == ERROR_SUCCESS)
  217.         && (RegQueryValueEx(key, "", NULL, NULL, NULL, &size)
  218.             == ERROR_SUCCESS)) {
  219.         Tcl_DStringSetLength(&ds, size);
  220.         RegQueryValueEx(key, "", NULL, NULL,
  221.             (LPBYTE) Tcl_DStringValue(&ds), &size);
  222.     }
  223.     }
  224.     Tcl_SetVar(interp, "tcl_library", Tcl_DStringValue(&ds), TCL_GLOBAL_ONLY);
  225.     if (Tcl_DStringLength(&ds) > 0) {
  226.     char *argv[3];
  227.     argv[0] = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
  228.     argv[1] = "lib";
  229.     argv[2] = NULL;
  230.     Tcl_DStringSetLength(&ds, 0);
  231.     Tcl_SetVar(interp, "tcl_pkgPath", Tcl_JoinPath(2, argv, &ds),
  232.         TCL_GLOBAL_ONLY|TCL_LIST_ELEMENT);
  233.     argv[1] = "lib/tcl" TCL_VERSION;
  234.     Tcl_DStringSetLength(&ds, 0);
  235.     Tcl_SetVar(interp, "tcl_library", Tcl_JoinPath(2, argv, &ds), 
  236.         TCL_GLOBAL_ONLY);
  237.     }
  238.  
  239.     /*
  240.      * Define the tcl_platform array.
  241.      */
  242.  
  243.     Tcl_SetVar2(interp, "tcl_platform", "platform", "windows",
  244.         TCL_GLOBAL_ONLY);
  245.     if (osInfo.dwPlatformId < NUMPLATFORMS) {
  246.     Tcl_SetVar2(interp, "tcl_platform", "os",
  247.         platforms[osInfo.dwPlatformId], TCL_GLOBAL_ONLY);
  248.     }
  249.     sprintf(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion);
  250.     Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY);
  251.     if (oemId->wProcessorArchitecture < NUMPROCESSORS) {
  252.     Tcl_SetVar2(interp, "tcl_platform", "machine",
  253.         processors[oemId->wProcessorArchitecture],
  254.         TCL_GLOBAL_ONLY);
  255.     }
  256.  
  257.     /*
  258.      * Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH
  259.      * environment variables, if necessary.
  260.      */
  261.  
  262.     ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY);
  263.     if (ptr == NULL) {
  264.     Tcl_DStringSetLength(&ds, 0);
  265.     ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY);
  266.     if (ptr != NULL) {
  267.         Tcl_DStringAppend(&ds, ptr, -1);
  268.     }
  269.     ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY);
  270.     if (ptr != NULL) {
  271.         Tcl_DStringAppend(&ds, ptr, -1);
  272.     }
  273.     if (Tcl_DStringLength(&ds) > 0) {
  274.         Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds),
  275.             TCL_GLOBAL_ONLY);
  276.     } else {
  277.         Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY);
  278.     }
  279.     }
  280.  
  281.     Tcl_DStringFree(&ds);
  282. }
  283.  
  284. /*
  285.  *----------------------------------------------------------------------
  286.  *
  287.  * Tcl_Init --
  288.  *
  289.  *    This procedure is typically invoked by Tcl_AppInit procedures
  290.  *    to perform additional initialization for a Tcl interpreter,
  291.  *    such as sourcing the "init.tcl" script.
  292.  *
  293.  * Results:
  294.  *    Returns a standard Tcl completion code and sets interp->result
  295.  *    if there is an error.
  296.  *
  297.  * Side effects:
  298.  *    Depends on what's in the init.tcl script.
  299.  *
  300.  *----------------------------------------------------------------------
  301.  */
  302.  
  303. int
  304. Tcl_Init(interp)
  305.     Tcl_Interp *interp;        /* Interpreter to initialize. */
  306. {
  307.     return Tcl_Eval(interp, initScript);
  308.  
  309. }
  310.  
  311. /*
  312.  *----------------------------------------------------------------------
  313.  *
  314.  * TclWinGetPlatform --
  315.  *
  316.  *    This is a kludge that allows the test library to get access
  317.  *    the internal tclPlatform variable.
  318.  *
  319.  * Results:
  320.  *    Returns a pointer to the tclPlatform variable.
  321.  *
  322.  * Side effects:
  323.  *    None.
  324.  *
  325.  *----------------------------------------------------------------------
  326.  */
  327.  
  328. TclPlatformType *
  329. TclWinGetPlatform()
  330. {
  331.     return &tclPlatform;
  332. }
  333.  
  334. /*
  335.  *----------------------------------------------------------------------
  336.  *
  337.  * Tcl_SourceRCFile --
  338.  *
  339.  *    This procedure is typically invoked by Tcl_Main of Tk_Main
  340.  *    procedure to source an application specific rc file into the
  341.  *    interpreter at startup time.
  342.  *
  343.  * Results:
  344.  *    None.
  345.  *
  346.  * Side effects:
  347.  *    Depends on what's in the rc script.
  348.  *
  349.  *----------------------------------------------------------------------
  350.  */
  351.  
  352. void
  353. Tcl_SourceRCFile(interp)
  354.     Tcl_Interp *interp;        /* Interpreter to source rc file into. */
  355. {
  356.     Tcl_DString temp;
  357.     char *fileName;
  358.     Tcl_Channel errChannel;
  359.  
  360.     fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
  361.  
  362.     if (fileName != NULL) {
  363.         Tcl_Channel c;
  364.     char *fullName;
  365.  
  366.         Tcl_DStringInit(&temp);
  367.     fullName = Tcl_TranslateFileName(interp, fileName, &temp);
  368.     if (fullName == NULL) {
  369.         /*
  370.          * Couldn't translate the file name (e.g. it referred to a
  371.          * bogus user or there was no HOME environment variable).
  372.          * Just do nothing.
  373.          */
  374.     } else {
  375.  
  376.         /*
  377.          * Test for the existence of the rc file before trying to read it.
  378.          */
  379.  
  380.             c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
  381.             if (c != (Tcl_Channel) NULL) {
  382.                 Tcl_Close(NULL, c);
  383.         if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
  384.             errChannel = Tcl_GetStdChannel(TCL_STDERR);
  385.             if (errChannel) {
  386.             Tcl_Write(errChannel, interp->result, -1);
  387.             Tcl_Write(errChannel, "\n", 1);
  388.             }
  389.         }
  390.         }
  391.     }
  392.         Tcl_DStringFree(&temp);
  393.     }
  394. }
  395.